home *** CD-ROM | disk | FTP | other *** search
/ Deutsche Edition 1 / Deutsche Edition 1.iso / amok / amok_lha / amok77.lha / Funktionen / Funktionen.mod < prev    next >
Text File  |  1993-08-15  |  14KB  |  418 lines
  1. (****************************************************************************
  2. :Program.       Funktionen.mod
  3. :Contents.      floating-point arithmetic compiler
  4. :Author.        Richard Günther [gvm]
  5. :Address.       HeilbronnerStr.267, 7410 Reutlingen
  6. :Phone.         07121/66432
  7. :Copyright.     Public Domain
  8. :Language.      Oberon
  9. :Translator.    AmigaOberon v2.14d
  10. :Imports.       ExecLists [gvm]
  11. :History.       V1.0 [gvm] 15-May-92  first implementation
  12. :History.       V1.1 [gvm] 05-July-92 cosmetic changes
  13. :Bugs.          does not support Commodores MathIEEESing-Libs because of
  14. :Bugs.          AmigaOberon not supporting them (number format problems)
  15. ****************************************************************************)
  16.  
  17. (* Compiler Grammar:
  18.       Ausdruck  = Summe.
  19.       Summe     = Produkt {("+"|"-") Produkt}.
  20.       Produkt   = Potenz {("*"|"/") Potenz}.
  21.       Potenz    = Faktor {"^" Faktor}.
  22.       Faktor    = ["+"|"-"](("(" Summe ")")|
  23.                             (Funktion "(" Summe ")")|
  24.                             Variable | Zahl | "pi" | "e").
  25.       Funktion  = "SIN" | "COS" | "TAN" |....
  26.       Zahl      = Ziffern["." Ziffern]["E"["+"|"-"] Ziffern].
  27.       Ziffern   = Ziffer {Ziffer}.
  28.       Variable  = CHAR.  *)
  29.  
  30. MODULE Funktionen ;
  31.  
  32. IMPORT  S   : SYSTEM,
  33.         O   : OberonLib,
  34.         E   : Exec,
  35.         EL  : ExecLists,
  36.         ST  : Strings,
  37.         RC  : RealConversions,
  38.         LRC : LongRealConversions ;
  39.  
  40.  
  41. TYPE  FunktionPtr = POINTER TO Funktion ;
  42.       Funktion    = RECORD (EL.Node)
  43.                       transLib  : E.LibraryPtr ;
  44.                       basLib    : E.LibraryPtr ;
  45.                       code      : LONGINT ;           (* code-speicher *)
  46.                     END ;
  47.  
  48.       Func      = STRUCT
  49.                     name  : ARRAY 6 OF CHAR ;
  50.                     offs  : INTEGER ;
  51.                     base  : INTEGER ;
  52.                   END ;
  53.       FArrayTyp = ARRAY 15 OF Func ;
  54.  
  55. CONST bas=0 ; trans=1 ;
  56. CONST FArray  = FArrayTyp("ABS",-54,bas,     "ACOS",-120,trans,
  57.                           "ASIN",-114,trans, "ATAN",-30,trans,
  58.                           "COS",-42,trans,   "COSH",-66,trans,
  59.                           "EXP",-78,trans,   "LN",-84,trans,
  60.                           "LOG",-126,trans,  "SIN",-36,trans,
  61.                           "SINH",-60,trans,  "SQRT",-96,trans,
  62.                           "TAN",-48,trans,   "TANH",-72,trans,
  63.                           "",0,0
  64.                          ) ;
  65.  
  66. (* Hier einige Standart-ProzedurTypen: *)
  67. TYPE  FuncX*    = PROCEDURE(x : REAL): REAL ;
  68.       FuncXL*   = PROCEDURE(x : LONGREAL): LONGREAL ;
  69.       FuncXY*   = PROCEDURE(x,y : REAL): REAL ;
  70.       FuncXYL*  = PROCEDURE(x,y : LONGREAL): LONGREAL ;
  71.  
  72. (* eins von diesen bitte bei Compile.precision angeben: *)
  73. CONST ffp*=0 ; single*=ffp ; double*=2 ;
  74.       (* Achtung !: OBERON unterstützt das SingleIEEE-Format nicht! *)
  75.       (* Deshalb ist single hier gleich ffp! *)
  76.  
  77. VAR funcList  : EL.List ;
  78.     pi,e      : REAL ;
  79.     piL,eL    : LONGREAL ;
  80.  
  81.  
  82. PROCEDURE Compile*(     source     : ARRAY OF CHAR ;
  83.                         vars       : ARRAY OF CHAR ;   (* z.B. "xy" *)
  84.                         precision  : INTEGER ;
  85.                    VAR  proc       : ARRAY OF BYTE ;   (* TermProzedur *)
  86.                    VAR  errpos     : INTEGER): BOOLEAN ;
  87. VAR func  : FunktionPtr ;
  88.     len   : INTEGER ;
  89.     code  : BOOLEAN ;
  90.     offs  : INTEGER ;
  91.     pos   : INTEGER ;
  92.     size  : INTEGER ;
  93.     numVars : INTEGER ;
  94.     lastPushed  : BOOLEAN ;
  95.     basInA6     : BOOLEAN ;
  96.     aPtr        : POINTER TO S.ADDRESS ;
  97.  
  98.   PROCEDURE Put2(w : INTEGER) ;
  99.   VAR iPtr  : POINTER TO INTEGER ;
  100.   BEGIN
  101.     IF code THEN
  102.       iPtr:=S.ADR(func.code) ; iPtr:=S.VAL(S.ADDRESS,S.VAL(LONGINT,iPtr)+offs) ;
  103.       iPtr^:=w ;
  104.     END ;
  105.     INC(offs,2) ;
  106.   END Put2 ;
  107.   PROCEDURE Put4(l : LONGINT) ;
  108.   VAR iPtr  : POINTER TO LONGINT ;
  109.   BEGIN
  110.     IF code THEN
  111.       iPtr:=S.ADR(func.code) ; iPtr:=S.VAL(S.ADDRESS,S.VAL(LONGINT,iPtr)+offs) ;
  112.       iPtr^:=l ;
  113.     END ;
  114.     INC(offs,4) ;
  115.   END Put4 ;
  116.  
  117.   PROCEDURE Push ;
  118.   BEGIN
  119.     IF precision=double THEN Put4(048E7C000H)         (* MOVEM.L D0-D1,-(SP) *)
  120.                         ELSE Put2(02F00H) ;           (* MOVE.L  D0,-(SP) *)
  121.     END ;
  122.     lastPushed:=TRUE ;
  123.   END Push ;
  124.   PROCEDURE Pea(data  : ARRAY OF BYTE) ;
  125.   VAR ptr : POINTER TO LONGINT ;
  126.       len : INTEGER ;
  127.   BEGIN
  128.     len:=LEN(data) ; ptr:=S.VAL(S.ADDRESS,S.VAL(LONGINT,S.ADR(data))+len-4) ;
  129.     WHILE len>0 DO
  130.       IF ptr^=LONG(SHORT(ptr^)) THEN Put2(04878H) ; Put2(SHORT(ptr^)) ; (* PEA data.W *)
  131.                                 ELSE Put2(04879H) ; Put4(ptr^) ;        (* PEA data.L *)
  132.       END ;
  133.       DEC(len,4) ; ptr:=S.VAL(S.ADDRESS,S.VAL(LONGINT,ptr)-4) ;
  134.     END ;
  135.     lastPushed:=FALSE ;
  136.   END Pea ;
  137.   PROCEDURE Pop ;
  138.   BEGIN
  139.     IF lastPushed THEN
  140.       IF precision=double THEN DEC(offs,4)
  141.                           ELSE DEC(offs,2)
  142.       END ;
  143.       lastPushed:=FALSE ;
  144.     ELSE
  145.       IF precision=double THEN Put4(04CDF0003H)     (* MOVEM.L (SP)+,D0-D1 *)
  146.                           ELSE Put2(0201FH)         (* MOVE.L  (SP)+,D0 *)
  147.       END ;
  148.     END ;
  149.   END Pop ;
  150.   PROCEDURE Pop2 ;
  151.   BEGIN
  152.     IF precision=double THEN
  153.       IF lastPushed THEN DEC(offs,4) ; Put4(024002601H) (* MOVE.L  D0/D1,D2/D3 *)
  154.                     ELSE Put4(04CDF000CH) ;             (* MOVEM.L (SP)+,D2-D3 *)
  155.       END ;
  156.       Put4(04CDF0003H)                                  (* MOVEM.L (SP)+,D0-D1 *)
  157.     ELSE
  158.       IF lastPushed THEN DEC(offs,2) ; Put2(02200H)        (* MOVE.L  D0,D1    *)
  159.                     ELSE Put2(0221FH) ;                    (* MOVE.L  (SP)+,D1 *)
  160.       END ;
  161.       Put2(0201FH)                                         (* MOVE.L  (SP)+,D0 *)
  162.     END ;
  163.     lastPushed:=FALSE ;
  164.   END Pop2 ;
  165.   PROCEDURE Load(varNo : INTEGER) ;
  166.   VAR of  : INTEGER ;
  167.   BEGIN
  168.     of:=varNo*4 ;
  169.     IF precision=double THEN Put2(02F2DH) ; Put2(2*of+4) ;
  170.                              Put2(02F2DH) ; Put2(2*of) ;
  171.                         ELSE Put2(02F2DH) ; Put2(of) ; (* MOVE.L of(A5),-(SP) *)
  172.     END ;
  173.     IF of=0 THEN DEC(offs,4) ; Put2(02F15H) END ;      (* MOVE.L (A5),-(SP) *)
  174.     lastPushed:=FALSE ;
  175.   END Load ;
  176.   PROCEDURE Call(base,offs : INTEGER) ;
  177.   BEGIN
  178.     IF ((base=bas) AND NOT basInA6) OR ((base=trans) AND basInA6) THEN
  179.       Put2(0C94EU) ; basInA6:=NOT basInA6 ;
  180.     END ;
  181.     Put2(04EAEH) ; Put2(offs) ;                    (* JSR offs(A6) *)
  182.   END Call ;
  183.  
  184.  
  185.   PROCEDURE Fehler ;
  186.   BEGIN
  187.     IF errpos=-1 THEN errpos:=pos ; pos:=256 END ;
  188.   END Fehler ;
  189.   PROCEDURE Match(c : CHAR):BOOLEAN ;
  190.   BEGIN
  191.     IF source[pos]=c THEN INC(pos) ; RETURN FALSE
  192.                      ELSE Fehler ; RETURN TRUE
  193.     END ;
  194.   END Match ;
  195.   PROCEDURE SkipBlanks ;
  196.   BEGIN
  197.     WHILE (pos<=len) AND (source[pos]=" ") DO INC(pos) END ;
  198.   END SkipBlanks ;
  199.  
  200.   PROCEDURE ^Summe(): BOOLEAN ;
  201.  
  202.   PROCEDURE ReadZiffern():BOOLEAN ;
  203.   BEGIN
  204.     IF (pos>len) OR ((source[pos]<"0") OR (source[pos]>"9")) THEN
  205.       Fehler ; RETURN TRUE END ;
  206.     WHILE (pos<=len) AND ((source[pos]>="0") AND (source[pos]<="9")) DO
  207.       INC(pos) END ;
  208.     RETURN FALSE ;
  209.   END ReadZiffern ;
  210.   PROCEDURE Zahl(negativ: BOOLEAN): BOOLEAN ;
  211.   VAR start: INTEGER ;
  212.       buf : ARRAY 32 OF CHAR ;
  213.       lr: LONGREAL ; r: REAL ;
  214.   BEGIN
  215.     start:=pos ;
  216.     IF ReadZiffern() THEN RETURN TRUE END ;
  217.     IF (pos<=len) AND (source[pos]=".") THEN
  218.       INC(pos) ; IF ReadZiffern() THEN RETURN TRUE END ;
  219.     END ;
  220.     IF (pos<=len) AND (source[pos]="E") THEN
  221.       INC(pos) ;
  222.       IF (pos<=len) AND ((source[pos]="+") OR (source[pos]="-")) THEN
  223.         INC(pos) ; END ;
  224.       IF ReadZiffern() THEN RETURN TRUE END ;
  225.     END ;
  226.     IF negativ THEN DEC(start) END ;
  227.     ST.Cut(source,start,pos-start,buf) ;
  228.     IF precision=double THEN
  229.       IF NOT LRC.StringToReal(buf,lr) THEN RETURN TRUE END ; Pea(lr) ;
  230.     ELSE
  231.       IF NOT RC.StringToReal(buf,r) THEN RETURN TRUE END ; Pea(r) ;
  232.     END ;
  233.     RETURN FALSE
  234.   END Zahl ;
  235.  
  236.   PROCEDURE Faktor():BOOLEAN ;
  237.   VAR negieren  : BOOLEAN ;
  238.       token     : ARRAY 8 OF CHAR ;
  239.       tpos      : INTEGER ;
  240.   BEGIN
  241.     SkipBlanks ;
  242.     negieren:=(pos<=len) AND (source[pos]="-") ;
  243.     IF (pos<=len) AND ((source[pos]="+") OR (source[pos]="-")) THEN
  244.       INC(pos)
  245.     END ;
  246.     IF (pos<=len) THEN
  247.       CASE source[pos] OF
  248.         "0".."9": IF Zahl(negieren) THEN RETURN TRUE END ;
  249.                   negieren:=FALSE |
  250.              "(": INC(pos) ;
  251.                   IF Summe() OR Match(")") THEN RETURN TRUE END |
  252.       ELSE
  253.         tpos:=0 ;
  254.         WHILE (source[pos]>="A") AND (source[pos]<="Z") DO
  255.           token[tpos]:=source[pos] ; INC(tpos) ; INC(pos) ;
  256.         END ;
  257.         token[tpos]:=CHR(0) ;
  258.         tpos:=0 ;
  259.         LOOP
  260.           WHILE FArray[tpos].name#"" DO
  261.             IF token=FArray[tpos].name THEN
  262.               IF Match("(")  OR  Summe()  OR  Match(")") THEN RETURN TRUE END ;
  263.               Pop ; Call(FArray[tpos].base,FArray[tpos].offs) ; Push ;
  264.               EXIT ;
  265.             END ;
  266.             INC(tpos) ;
  267.           END ;
  268.           IF    token="PI" THEN
  269.             IF precision=double THEN Pea(piL)
  270.                                 ELSE Pea(pi)
  271.             END ;
  272.           ELSIF token="E" THEN
  273.             IF precision=double THEN Pea(eL)
  274.                                 ELSE Pea(e)
  275.             END ;
  276.           ELSIF token[1]=CHR(0) THEN
  277.             tpos:=0 ;
  278.             WHILE tpos#numVars DO
  279.               IF vars[tpos]=token[0] THEN
  280.                 Load(numVars-tpos-1) ;          (* umgekehrte Reihenfolge ! *)
  281.                 EXIT ;
  282.               END ;
  283.               INC(tpos) ;
  284.             END ;
  285.             Fehler ;
  286.           ELSE Fehler ; RETURN TRUE
  287.           END ;
  288.           EXIT ;
  289.         END ;
  290.       END ;
  291.     END ;
  292.     IF negieren THEN
  293.       Pop ; Call(bas,-60) ; Push ;     (* Neg *)
  294.     END ;
  295.     SkipBlanks ;
  296.     RETURN FALSE ;
  297.   END Faktor ;
  298.  
  299.   PROCEDURE Potenz(): BOOLEAN ;
  300.   BEGIN
  301.     IF Faktor() THEN RETURN TRUE END ;
  302.     WHILE (pos<=len) AND (source[pos]="^") DO
  303.       INC(pos) ;
  304.       IF Faktor() THEN RETURN TRUE END ;
  305.       Pop2 ; Call(trans,-90) ; Push ;   (* Pow *)
  306.     END ;
  307.     RETURN FALSE ;
  308.   END Potenz ;
  309.  
  310.   PROCEDURE Produkt(): BOOLEAN ;
  311.   VAR ch  : CHAR ;
  312.   BEGIN
  313.     IF Potenz() THEN RETURN TRUE END ;
  314.     WHILE (pos<=len) AND ((source[pos]="*") OR (source[pos]="/")) DO
  315.       ch:=source[pos] ; INC(pos) ;
  316.       IF Potenz() THEN RETURN TRUE END ;
  317.       Pop2 ;
  318.       IF ch="*" THEN Call(bas,-78)     (* Mul *)
  319.                 ELSE Call(bas,-84)     (* Div *)
  320.       END ;
  321.       Push ;
  322.     END ;
  323.     RETURN FALSE ;
  324.   END Produkt ;
  325.  
  326.   PROCEDURE Summe(): BOOLEAN ;
  327.   VAR ch  : CHAR ;
  328.   BEGIN
  329.     IF Produkt() THEN RETURN TRUE END ;
  330.     WHILE (pos<=len) AND ((source[pos]="+") OR (source[pos]="-")) DO
  331.       ch:=source[pos] ; INC(pos) ;
  332.       IF Produkt() THEN RETURN TRUE END ;
  333.       Pop2 ;
  334.       IF ch="+" THEN Call(bas,-66)     (* Add *)
  335.                 ELSE Call(bas,-72)     (* Sub *)
  336.       END ;
  337.       Push ;
  338.     END ;
  339.   END Summe ;
  340.  
  341.   PROCEDURE Ausdruck(): BOOLEAN ;
  342.   BEGIN
  343.     pos:=0 ; errpos:=-1 ; lastPushed:=FALSE ; basInA6:=TRUE ;
  344.     ST.Upper(vars) ; numVars:=ST.Length(vars) ;
  345.     Put4(048E7300EH) ;                (* movem.l  d2-d3/a4-6,-(sp) *)
  346.     Put4(04BEF0018H) ;                (* lea 24(a7),a5 *)
  347.     Put2(02C7AH) ; Put2(-4-offs) ;    (* move.l   -4(func.code),A6 *)
  348.     Put2(0287AH) ; Put2(-8-offs) ;    (* move.l   -8(func.code),A4 *)
  349.     IF Summe() OR
  350.        (offs=16) THEN RETURN TRUE END ; (* "leerer" code ? *)
  351.     Pop ; (* Ergebnis in D0/D1 *)
  352.     Put4(04CDF700CH) ;                (* movem.l  (sp)+,d2-d3/a4-6 *)
  353.     Put2(0205FH) ;                    (* move.l   (sp)+,a0   rts-adr *)
  354.     IF numVars#0 THEN
  355.       Put2(04FEFH) ;                  (* lea      numvars*prec(a7),a7 *)
  356.       IF precision=double THEN Put2(numVars*8)
  357.                           ELSE Put2(numVars*4)
  358.       END ;
  359.     END ;
  360.     Put2(04ED0H) ;                    (* jmp (a0) *)
  361.     RETURN FALSE ;
  362.   END Ausdruck ;
  363.  
  364. BEGIN
  365.   ST.Upper(source) ; len:=ST.Length(source) ;
  366.   code:=FALSE ; offs:=0 ;
  367.   IF (len=0) OR Ausdruck() THEN RETURN FALSE END ;
  368.   size:=offs+S.SIZE(Funktion) ; O.New(func,size) ;
  369.   IF func=NIL THEN errpos:=-2 ; RETURN FALSE END ;
  370.   S.INIT(func) ;
  371.   CASE precision OF
  372.        ffp : func.basLib:=E.OpenLibrary("mathffp.library",0) ;
  373.              func.transLib:=E.OpenLibrary("mathtrans.library",0) |
  374. (*    single : func.basLib:=E.OpenLibrary("mathieeesingbas.library",0) ;
  375.              func.transLib:=E.OpenLibrary("mathieeesingtrans.library",0) | *)
  376.     double : func.basLib:=E.OpenLibrary("mathieeedoubbas.library",0) ;
  377.              func.transLib:=E.OpenLibrary("mathieeedoubtrans.library",0) |
  378.   END ;
  379.   IF (func.basLib=NIL) OR (func.transLib=NIL) THEN
  380.     IF func.transLib#NIL THEN E.CloseLibrary(func.transLib) ;
  381.     ELSIF func.basLib#NIL THEN E.CloseLibrary(func.basLib) ;
  382.     END ;
  383.     DISPOSE(func) ; errpos:=-2 ;
  384.     RETURN FALSE ;
  385.   END ;
  386.   code:=TRUE ; offs:=0 ;
  387.   IF Ausdruck() THEN END ;
  388.   EL.AddHead(funcList,func) ;
  389.   aPtr:=S.ADR(proc) ; aPtr^:=S.ADR(func.code) ;
  390.   RETURN TRUE ;
  391. END Compile ;
  392.  
  393. (* unschön, aber praktisch (keine Typenumwandlung nötig) *)
  394. PROCEDURE Dispose*{"Funktionen.Dis"}(VAR func{8} : ARRAY OF BYTE) ;
  395. PROCEDURE Dis*(VAR func{8} : FunktionPtr) ;  (* eigentlich Funktion.code *)
  396. BEGIN
  397.   func:=S.VAL(FunktionPtr,S.VAL(LONGINT,func)-S.SIZE(Funktion)+8) ;
  398.   E.CloseLibrary(func.transLib) ;
  399.   E.CloseLibrary(func.basLib) ;
  400.   EL.Remove(func) ;
  401.   DISPOSE(func) ;
  402. END Dis ;
  403. PROCEDURE CloseDispose*(func : EL.NodePtr) ; (* nur wegen VAR-Parameter nötig *)
  404. BEGIN
  405.   func:=S.ADR(func(Funktion).code) ;
  406.   Dispose(func) ;
  407. END CloseDispose ;
  408.  
  409.  
  410. BEGIN
  411.   EL.Init(funcList) ;
  412.   pi:=3.141592654 ; e:=2.718281828 ;
  413.   piL:=3.141592653589793 ; eL:=2.718281828459045 ;
  414. CLOSE
  415.   EL.DoForward(funcList,CloseDispose) ;
  416. END Funktionen.
  417.  
  418.